Delphi 2.0 - Programmer's Utilities Power Pack/Delphi 2.0 Programmer's Utilities Power Pack.iso/a_to_d/dwsock11/dwinsock.pas

Pascal/Delphi Source File | 1996-09-15 | 21.6 KB | 904 lines

{--------------------------------------------------------------
    WinSock component for Borland Delphi.

    (C) 1995 by Ulf S÷derberg, [e-mail]

  History
      V1.0        950404        US            First release.

    Parts of this code was inspired by WINSOCK.PAS by Marc B. Manza.
---------------------------------------------------------------}

unit DWinSock;

interface

uses
    SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
    Forms, Dialogs;

const
    CM_SOCKMSG    = WM_USER+1;
    MAXCONN            = 16;                                        { allow 16 clients for TServerSockets }

{$I winsock.inc }
{$I winsock.if }

type
    { DWinSock exception type }
    ESockError = class(Exception);

  TSocket = class;                                        { Forward declaration }

    { Socket info codes }
  TSockInfo = (siLookUp, siConnect, siListen, siRecv, siSend);

    {    Define notification events for socket controls. }
    TSockInfoEvent = procedure (Sender : TObject; icode : TSockInfo) of object;
    TClientEvent = TNotifyEvent;
    TServerEvent = procedure (Sender : TObject; cid : integer) of object;

    {    TSockCtrl -- socket control component base class. }
    TSockCtrl = class(TCustomControl)
    private
        {    Event handler references }
        FOnInfo                    : TSockInfoEvent;

        { Design tim connection info }
        FHost                        : string;
    FAddress                : string;
        FService                : string;
    FPort                        : u_short;

    { Run time connection info }
        FConn                        : TSocket;

        { Design time bitmap }
    FPicture                : TBitmap;

        { Access functions }
        procedure SetService(const s : string);
        procedure SetHost(const n : string);
        procedure SetAddress(const a : string);
        procedure SetPort(p : u_short);

        { Returns the WinSock.DLL description }
        function GetDescription : string;

    protected
        { Protected declarations }
        constructor Create(AOwner : TComponent); override;
        destructor Destroy; override;
        procedure Paint; override;
        procedure OnSizeChanged(var Message : TWMSize); message WM_SIZE;

    public
        { Public declarations }
    procedure Info(icode : TSockInfo);
        function LocalHost : string;
        function Reverse(var a : string) : string;

        property Conn : TSocket read FConn;
        property Description : string read GetDescription;

    published
        { Published declarations }
        property Address : string read FAddress write SetAddress;
        property Port : u_short read FPort write SetPort;
        property Service : string read FService write SetService;
    property OnInfo : TSockInfoEvent read FOnInfo write FOnInfo;
    end;

    { Definition of the TClientSocket component class }
    TClientSocket = class(TSockCtrl)
    private
        {    Event handler references }
        FOnConnect            : TClientEvent;
        FOnDisconnect        : TClientEvent;
        FOnRead                    : TClientEvent;
        FOnWrite                : TClientEvent;

    protected
        { Protected declarations }
        procedure OnSockMsg(var Message : TMessage); message CM_SOCKMSG;

    public
        { Public declarations }
    procedure Open;
        procedure Close;
        function SendBuf(var buf; cnt : integer) : integer;
        function RecvBuf(var buf; cnt : integer) : integer;

    function GetBytesSent : integer;
        function RecvText : string;
    procedure SendText(const s : string);

    property BytesSent : integer read GetBytesSent;
    property Text : string read RecvText write SendText;

    published
        { Published declarations }
         constructor Create(AOwner : TComponent); override;
        destructor Destroy; override;

        property Host : string read FHost write SetHost;

        property OnConnect : TClientEvent read FOnConnect write FOnConnect;
        property OnDisconnect : TClientEvent read FOnDisconnect write FOnDisconnect;
        property OnRead : TClientEvent read FOnRead write FOnRead;
        property OnWrite : TClientEvent read FOnWrite write FOnWrite;
    property OnInfo;
    end;

    { Definition of the TServerSocket component class }
    TServerSocket = class(TSockCtrl)
    private
        {    Event handler references }
        FOnAccept                : TServerEvent;
        FOnDisconnect        : TServerEvent;
        FOnRead                    : TServerEvent;
        FOnWrite                : TServerEvent;

        FConns                    : array [1..MAXCONN] of TSocket;

        function GetClient(cid : integer) : TSocket;

        function DoAccept : integer;

    protected
        { Protected declarations }
        procedure OnSockMsg(var Message : TMessage); message CM_SOCKMSG;

    public
        { Public declarations }
         constructor Create(AOwner : TComponent); override;
        destructor Destroy; override;

    procedure Listen(nqlen : integer);
        procedure Close;

        { Return client socket }
        property Client[cid : integer] : TSocket read GetClient; default;

    published
        { Published declarations }
        property OnAccept : TServerEvent read FOnAccept write FOnAccept;
        property OnDisconnect : TServerEvent read FOnDisconnect write FOnDisconnect;
        property OnRead : TServerEvent read FOnRead write FOnRead;
        property OnWrite : TServerEvent read FOnWrite write FOnWrite;
        property OnInfo;
    end;

    { TSocket -- socket api wrapper class. }
    TSocket = class(TObject)
    public
        FParent                    : TSockCtrl;                        { socket owner }
        FSocket                    : TSock;                                { socket id }
        FAddr                        : sockaddr_in;                    { host address }
        FConnected            : boolean;
        FBytesSent            : integer;                            { bytes sent by last SendBuf call }

        constructor Create(AParent : TSockCtrl);
        destructor Destroy;

    function LookupName(var name : string) : in_addr;
    function LookupService(var service : string) : u_short;
        procedure FillSocket(var name, addr, service : string; var port : u_short);

        function LocalAddress : string;
        function LocalPort : integer;

        function RemoteHost : string;
        function RemoteAddress : string;
        function RemotePort : integer;

        procedure Listen(var name, addr, service : string; port : u_short; nqlen : integer);
        procedure Open(var name, addr, service : string; port : u_short);
        procedure Close;

        function SendBuf(var buf; cnt : integer) : integer;
        function RecvBuf(var buf; cnt : integer) : integer;

        function RecvText : string;
    procedure SendText(const s : string);

    property BytesSent : integer read FBytesSent;
    property Text : string read RecvText write SendText;
    end;

procedure Register;

implementation

{$R DWINSOCK}

var
    ExitSave    : Pointer;
    bStarted  : boolean;
    nUsers    : integer;
    nWSErr    : integer;
    myVerReqd : word;
  myWSAData : WSADATA;

{$I ERROR.INC}

{ StartUp -- See if a Windows Socket DLL is present on the system. }
procedure StartUp;
begin
    if bStarted then exit;
  nUsers := 0;
    myVerReqd:=$0101;
    nWSErr := WSAStartup(myVerReqd,@myWSAData);
    if nWSErr = 0 then
        bStarted := true
    else
        raise ESockError.Create('Can''t startup WinSock');
end;

{ CleanUp -- Tell Windows Socket DLL we don't need its services any longer. }
procedure CleanUp; far;
begin
    ExitProc := ExitSave;
    if bStarted then
    begin
      nWSErr := WSACleanup;
      bStarted := false;
        end;
end;

{--------------------------------------------------------------
    TSocket implementation
 --------------------------------------------------------------}

constructor TSocket.Create(AParent : TSockCtrl);
begin
    inherited Create;
  FParent := AParent;
    FSocket := INVALID_SOCKET;
    FAddr.sin_family := PF_INET;
    FAddr.sin_addr.s_addr := INADDR_ANY;
  FAddr.sin_port := 0;
    FConnected := false;
    FBytesSent := 0;
end;

destructor TSocket.Destroy;
begin
    if FConnected {or (FSocket <> INVALID_SOCKET)} then
        CloseSocket(FSocket);
    inherited Destroy;
end;

{ LocalAddress -- get local address }
function TSocket.LocalAddress : string;
var
    sa : sockaddr_in;
    nl : integer;
begin
    Result := '';
    if FSocket = INVALID_SOCKET then exit;
    if getsockname(FSocket, PSockaddr(@sa), @nl) = 0 then
        Result := StrPas(inet_ntoa(sa.sin_addr));
end;

{ LocalPort -- get local port number }
function TSocket.LocalPort : integer;
var
    sa : sockaddr_in;
    nl : integer;
begin
    Result := 0;
    if FSocket = INVALID_SOCKET then exit;
    if getsockname(FSocket, PSockaddr(@sa), @nl) = 0 then
        Result := ntohs(sa.sin_port);
end;

{ RemoteHost -- get name of connected remote host }
function TSocket.RemoteHost : string;
var
    sa    : sockaddr_in;
  nl    : integer;
    phe : PHostEnt;
begin
    Result := '';
    if not FConnected then exit;
    { Get connection address info }
    getpeername(FSocket, PSockaddr(@sa), @nl);
    FAddr := sa;
  { Do a reverse lookup to get the host name }
    phe := gethostbyaddr(PChar(@FAddr.sin_addr.s_addr), 4, PF_INET);
    if phe <> nil then
        Result := StrPas(phe^.h_name);
end;

{ RemoteAddress -- get address of connected remote host }
function TSocket.RemoteAddress : string;
var
    sa : sockaddr_in;
    nl : integer;
begin
    Result := '?';
    if (FSocket = INVALID_SOCKET) or (not FConnected) then exit;
    if getpeername(FSocket, PSockaddr(@sa), @nl) = 0 then
        Result := StrPas(inet_ntoa(sa.sin_addr));
end;

{ RemotePort -- get remote port number }
function TSocket.RemotePort : integer;
var
    sa : sockaddr_in;
    nl : integer;
begin
    Result := 0;
    if (FSocket = INVALID_SOCKET) or (not FConnected) then exit;
    if getpeername(FSocket, PSockaddr(@sa), @nl) = 0 then
        Result := ntohs(sa.sin_port)
    else
        Result := 0;
end;

{ LookupName -- try to look up host name }
function TSocket.LookupName(var name : string) : in_addr;
var
    phe    : PHostEnt;
    sz    : array [1..64] of char;
  sa    : in_addr;
begin
    StrPCopy(@sz, name);
    phe := gethostbyname(@sz);
    if phe <> nil then
        begin
            phe^.h_addr := phe^.h_addr_list^;
            sa.S_un_b.s_b1:=phe^.h_addr[0];
            sa.S_un_b.s_b2:=phe^.h_addr[1];
            sa.S_un_b.s_b3:=phe^.h_addr[2];
            sa.S_un_b.s_b4:=phe^.h_addr[3];
      Result := sa;
    end
  else
      raise ESockError.Create('Can''t find host ' + name);
end;

{ LookupService -- try to lookup service name }
function TSocket.LookupService(var service : string) : u_short;
var
    ps    : PServEnt;
    proto    : array [1..32] of char;
    name : array [1..64] of char;
begin
    Result := 0;
    StrPCopy(@proto, 'tcp');
    StrPCopy(@name, service);
    ps := getservbyname(@name, @proto);
    if ps <> nil then
        Result := ps^.s_port
    else
        raise ESockError.Create('Can''t find port for service ' + service);
end;

{ FillSocket -- fill in address and port fields in socket struct }
procedure TSocket.FillSocket(var name, addr, service : string; var port : u_short);
var
    s    : array [1..32] of char;
begin
    { Fill in address field }
    if name <> '' then                        { Host name given }
      begin
          FAddr.sin_addr := LookupName(name);
      addr := StrPas(inet_ntoa(FAddr.sin_addr));
    end
  else if addr <> '' then                { IP address given }
      begin
          StrPCopy(@s, addr);
          FAddr.sin_addr.s_addr := inet_addr(@s);
    end
    else                                                    { Neither name or address given }
      raise ESockError.Create('No address specified');

    { Fill in port number field }
  if service <> '' then
      begin
            FAddr.sin_port := LookupService(service);
      port := ntohs(FAddr.sin_port);
    end
  else
      FAddr.sin_port := htons(port);
end;

{ Listen -- wait for incoming connection. }
procedure TSocket.Listen(var name, addr, service : string; port : u_short; nqlen : integer);
var
    q, e    : integer;
begin
    if (not bStarted) then
      raise ESockError.Create('WINSOCK not started');

    FSocket := DWinsock.socket(PF_INET, SOCK_STREAM, IPPROTO_IP);
    if FSocket = INVALID_SOCKET then
      raise ESockError.Create('Can''t create new socket');

  FillSocket(name, addr, service, port);

    if bind(FSocket, Psockaddr(@FAddr), SizeOf(FAddr)) <> 0 then
        begin
        e := WSAGetLastError;
            Close;
            raise ESockError.Create('Bind failed, '+Error(e));
        end;

    WSAAsyncSelect(FSocket, FParent.Handle, CM_SOCKMSG, FD_ACCEPT or FD_CLOSE or FD_READ or FD_WRITE);

    q := MAXCONN;
    if nqlen < q then
        q := nqlen;

    if DWinsock.listen(FSocket, q) <> 0 then
        begin
            e := WSAGetLastError;
            Close;
            raise ESockError.Create('Listen failed, '+Error(e));
        end;
end;

{    Open a connection. }
procedure TSocket.Open(var name, addr, service : string; port : u_short);
begin
    if (not bStarted) then
      raise ESockError.Create('WINSOCK not started');

  if FConnected then
      raise ESockError.Create('Can''t open an open socket');

    FSocket := DWinsock.socket(PF_INET, SOCK_STREAM, IPPROTO_IP);
    if FSocket = INVALID_SOCKET then
      raise ESockError.Create('Can''t create new socket');

  FParent.Info(siLookUp);
  FillSocket(name, addr, service, port);

    WSAAsyncSelect(FSocket, FParent.Handle, CM_SOCKMSG, FD_CONNECT or FD_CLOSE or FD_READ or FD_WRITE);

  FParent.Info(siConnect);
    if connect(FSocket, Psockaddr(@FAddr), SizeOf(FAddr)) <> 0 then
        if WSAGetLastError <> WSAEWOULDBLOCK then
            begin
                Close;
                raise ESockError.Create('Open failed');
            end;
end;

procedure TSocket.Close;
begin
    if (not bStarted) or (FSocket = INVALID_SOCKET) then exit;
    closesocket(FSocket);
    {FSocket := INVALID_SOCKET;}
  FConnected := false;
    FBytesSent := 0;
end;

function TSocket.RecvText : string;
var
  n        : integer;
begin
    n := RecvBuf(PChar(@Result[1])^, 255);
  Result[0] := char(n);
end;

procedure TSocket.SendText(const s : string);
begin
    FBytesSent := SendBuf(PChar(@s[1])^, Length(s));
end;

{    Send contents of passed buffer. }
function TSocket.SendBuf(var buf; cnt : integer) : integer;
var
    n : integer;
begin
    Result := 0;
    if (FSocket = INVALID_SOCKET) or (not FConnected) then exit;
    n := send(FSocket, @buf, cnt, 0);
    if n > 0 then
        Result := n
    else if (n = SOCKET_ERROR) and (WSAGetLastError <> WSAEWOULDBLOCK) then
      begin
            Close;
      raise ESockError.Create('Send error');
    end;
end;

{    Request that passed buffer be filled with received data. }
function TSocket.RecvBuf(var buf; cnt : integer) : integer;
var
    n : integer;
begin
    Result := 0;

    if (FSocket = INVALID_SOCKET) or (not FConnected) then
      raise ESockError.Create('Socket not open');

    n := recv(FSocket, @buf, cnt, 0);
    if n > 0 then
        Result := n
  else if (n = SOCKET_ERROR) and (WSAGetLastError <> WSAEWOULDBLOCK) then
      begin
        Close;
          raise ESockError.Create('Recv error');
    end;
end;

{--------------------------------------------------------------
    TSockCtrl implementation
 --------------------------------------------------------------}

{ Create -- initalization }
constructor TSockCtrl.Create(AOwner : TComponent);
begin
    inherited Create(AOwner);
    FConn := TSocket.Create(self);
    { Create design bitmap }
    FPicture := TBitmap.Create;

    { The control should be visible at design time only.
      At run time, check if the WINSOCK has been started. }
    if csDesigning in ComponentState then
        Visible := true
    else
      begin
            Visible := false;
          StartUp;
    end;

  FHost := '';
  FAddress := '0.0.0.0';

  FService := '';
  FPort := 0;

    inc(nUsers);
end;

{ Destroy -- destruction }
destructor TSockCtrl.Destroy;
var
    res : integer;
begin
     FConn.Destroy;
    dec(nUsers);
  if nUsers <= 0 then
        CleanUp;
  FPicture.Destroy;
    inherited Destroy;
end;

{ OnSizeChanged -- this procedure is called at design time if the designer
    is trying to resize the control on the form. It will force the control to
  be the size of the bitmap. }
procedure TSockCtrl.OnSizeChanged(var Message : TWMSize);
begin
    Height := FPicture.Height;
  Width := FPicture.Width;
end;

{ Paint -- show the bitmap at design time. }
procedure TSockCtrl.Paint;
begin
    if csDesigning in ComponentState then
        Canvas.Draw(0, 0, FPicture);
end;

{ Info -- call the OnInfo event handler if any. }
procedure TSockCtrl.Info(icode : TSockInfo);
begin
    if Assigned(FOnInfo) then
      FOnInfo(self, icode);
end;

{ GetDescription -- return description of WinSock implementation }
function TSockCtrl.GetDescription : string;
begin
    Result := StrPas(myWSAdata.szDescription);
end;

{ LocalHost -- return name of local host }
function TSockCtrl.LocalHost : string;
var
    sh : array [0..255] of char;
begin
    if not bStarted then
        begin
            Result := '';
            exit;
        end;
    if gethostname(sh, 255) = 0 then
        Result := StrPas(sh)
    else
        Result := '';
end;

{ Set host name }
procedure TSockCtrl.SetHost(const n : string);
begin
    FHost := n;
  FAddress := '';
end;

{ Set host address }
procedure TSockCtrl.SetAddress(const a : string);
begin
    FAddress := a;
  FHost := '';
end;

{ Set service name }
procedure TSockCtrl.SetService(const s : string);
begin
    FService := s;
  FPort := 0;
end;

{ Set port number }
procedure TSockCtrl.SetPort(p : u_short);
begin
    FPort := p;
  FService := '';
end;

{ Reverse -- try to do a reverse lookup }
function TSockCtrl.Reverse(var a : string) : string;
var
    phe    : PHostEnt;
    s        : array[0..31] of char;
    sa    : in_addr;
begin
    StrPCopy(s, a);
    sa.s_addr := inet_addr(s);
    if sa.s_addr = 0 then
        raise ESockError.Create('Can''t do reverse lookup on address 0.0.0.0');

    phe := gethostbyaddr(PChar(@sa.s_addr), 4, PF_INET);
    if phe <> nil then
        Result := StrPas(phe^.h_name)
    else
        raise ESockError.Create('Reverse lookup on ' + a + ' failed');
end;

{--------------------------------------------------------------
    TClientSocket implementation.
 --------------------------------------------------------------}

constructor TClientSocket.Create(AOwner : TComponent);
begin
    inherited Create(AOwner);
  FPicture.Handle := LoadBitmap(HInstance, 'CLIENT');
end;

destructor TClientSocket.Destroy;
begin
    inherited Destroy;
end;

procedure TClientSocket.Open;
begin
    FConn.Open(FHost, FAddress, FService, FPort);
end;

procedure TClientSocket.Close;
begin
    FConn.Close;
end;

function TClientSocket.GetBytesSent : integer;
begin
    Result := FConn.FBytesSent;
end;

function TClientSocket.RecvText : string;
begin
    Result := FConn.RecvText;
end;

procedure TClientSocket.SendText(const s : string);
begin
    FConn.SendText(s);
end;

function TClientSocket.SendBuf(var buf; cnt : integer) : integer;
begin
    Result := FConn.SendBuf(buf, cnt);
end;

function TClientSocket.RecvBuf(var buf; cnt : integer) : integer;
begin
    Result := FConn.RecvBuf(buf, cnt);
end;

procedure TClientSocket.OnSockMsg(var Message : TMessage);
    var
        sock : TSock;
        evt, err : word;
    begin
        sock := TSock(Message.wParam);
        evt := WSAGetSelectEvent(Message.lParam);
        err := WSAGetSelectError(Message.lParam);

        case evt of
            FD_CONNECT:
                begin
                    FConn.FConnected := true;
                    if Assigned(FOnConnect) then
                        FOnConnect(self);
                end;

            FD_CLOSE:
                begin
                    if FConn.FConnected then
                        closesocket(FConn.FSocket);
                    FConn.FConnected := false;
                    FConn.FSocket := INVALID_SOCKET;
                    if Assigned(FOnDisconnect) then
                        FOnDisconnect(self);
                end;

            FD_OOB: ;
            FD_READ:
                if Assigned(FOnRead) then
                    FOnRead(self);

            FD_WRITE:
                if Assigned(FOnWrite) then
                    FOnWrite(self);
        end;
    end;

{--------------------------------------------------------------
    TServerSocket functions
 --------------------------------------------------------------}

constructor TServerSocket.Create(AOwner : TComponent);
var
    i    : integer;
begin
    inherited Create(AOwner);
    for i := 1 to MAXCONN do
        FConns[i] := TSocket.Create(self);
  FPicture.Handle := LoadBitmap(HInstance, 'SERVER');
end;

destructor TServerSocket.Destroy;
var
    i : integer;
begin
    for i := 1 to MAXCONN do
        FConns[i].Destroy;
    inherited Destroy;
end;

function TServerSocket.GetClient(cid : integer) : TSocket;
    begin
        Result := FConns[cid];
    end;

procedure TServerSocket.Close;
begin
    FConn.Close;
end;

procedure TServerSocket.OnSockMsg(var Message : TMessage);
var
    sock    : TSock;
    evt        : word;
  err        : word;
    cid        : integer;

    procedure FindConn;
    var
        i        : integer;
    begin
        cid := 0;
        for i := 1 to MAXCONN do
            if FConns[i].FSocket = sock then
                begin
                    cid := i;
                    exit;
                end;
    end;

begin
    sock := TSock(Message.wParam);
    evt := WSAGetSelectEvent(Message.lParam);
    err := WSAGetSelectError(Message.lParam);

    case evt of
        FD_ACCEPT:
            begin
                cid := DoAccept;
                if Assigned(FOnAccept) and (cid > 0) then
                    FOnAccept(self, cid);
            end;

        FD_CLOSE:
            begin
                FindConn;
                if not FConns[cid].FConnected then
                    closesocket(FConns[cid].FSocket);
                FConns[cid].FConnected := false;
                FConns[cid].FSocket := INVALID_SOCKET;
                if Assigned(FOnDisconnect) then
                    FOnDisconnect(self, cid);
            end;

        FD_OOB: ;
        FD_READ:
            begin
                FindConn;
                if Assigned(FOnRead) then
                    FOnRead(self, cid);
            end;

        FD_WRITE:
            begin
                FindConn;
                if Assigned(FOnWrite) then
                    FOnWrite(self, cid);
            end;
    end;
end;

function TServerSocket.DoAccept : integer;
var
    ts    : TSocket;
    nl    : integer;
    cid    : integer;

    function NewConn : integer;
    var
        i        : integer;
    begin
        Result := 0;
        for i := 1 to MAXCONN do
            if FConns[i].FSocket = INVALID_SOCKET then
                begin
                    Result := i;
                    exit;
                end;
    end;

begin
    Result := 0;
    cid := NewConn;
    ts := FConns[cid];
    nl := sizeof(sockaddr_in);
    ts.FSocket := accept(FConn.FSocket, PSockaddr(@ts.FAddr), @nl);
    if ts.FSocket <> INVALID_SOCKET then
        begin
            {WSAAsyncSelect(ts.FSocket, Handle, CM_SOCKMSG, FD_CLOSE or FD_READ or FD_WRITE);}
            ts.FConnected := true;
            Result := cid;
        end;
end;

procedure TServerSocket.Listen(nqlen : integer);
begin
    FConn.Listen(FHost, FAddress, FService, FPort, nqlen);
end;

{    Register our components. }
procedure Register;
begin
    RegisterComponents('Samples', [TClientSocket]);
    RegisterComponents('Samples', [TServerSocket]);
end;

{$I winsock.imp }

{--------------------------------------------------------------
    Unit initialization code.
 --------------------------------------------------------------}

initialization
    bStarted := false;
    ExitSave := ExitProc;
  ExitProc := @CleanUp;
end.